home *** CD-ROM | disk | FTP | other *** search
program ListDemo; (* Demonstration of the List Manager, written June 24-25, 1988 by Richard Clark. *) (* (eMail:: GEnie/MCI/DELPHI/MouseHole -- RDCLARK. CompuServe users should use the *) (* MCI gateway.) *) (* Written at the request of Kevin-Neil Klop of the Borland Product Support Roundtable *) (* on the GEnie network. *) (* This software is in the Public Domain, and may be used and modified freely. *) {*** Modernized by Ingemar R 1995: ***} {Added compilation switches for Think and Metrowerks (while keeping enough of} {the old stuff to make the few Turbo users - any left? - happy).Added window} {dragging.} {Old compilation switches - beware for ones that have different meaning. /IR} {$U- Don’t use standard I/O } {$D+ Generate MacsBug symbols } {$B+ Set the bundle bit, so we can have an icon } {$T APPL•PAS} (* define the type and creator *) {$R ListDemo.rsrc} {Uses, not needed for Think /IR} {$IFC UNDEFINED THINK_PASCAL} {$IFC UNDEFINED MWERKS} {Old uses for Turbo Pascal} uses MemTypes, QuickDraw, OSIntf, ToolIntf, PackIntf; {$ELSEC} {MetroWerks, i.e. UPI} uses Types, QuickDraw, Menus, Windows, Events, Fonts, Lists, {} TextEdit, Dialogs, Resources, ToolUtils, Devices; {$ENDC} {$ENDC} {$IFC UNDEFINED MWERKS} {UPI names for some functions. I prefer keeping a big unit for these, so I can} {use the same in every project that supports both TP and MWP. /IR} {AddResMenu} procedure AppendResMenu (theMenu: MenuHandle; theType: ResType); inline $A94D; {LDoDraw} procedure LSetDrawingMode (drawIt: BOOLEAN; lHandle: ListHandle); inline $3F3C, $002C, $A9E7; {GetItem} procedure GetMenuItemText (theMenu: MenuHandle; item: INTEGER; var itemString: Str255); inline $A946; {TextBox} procedure TETextBox (text: univ Ptr; length: LONGINT; {CONST} var box: Rect; just: INTEGER); inline $A9CE; {$ENDC} const mApple = 128; (* Apple menu *) iaAbout = 1; mFile = 129; (* File menu *) ifNew = 1; ifClose = 2; {----------------} ifQuit = 4; wList = 128; (* "List Window" has a resource id of 128 *) dAbout = 128; (* and so does our 'About" dialog *) sizes = 128; (* The ID of a STR# containing our list of *) (* possible font sizes. *) var quit: Boolean; AppleMenu, FileMenu: MenuHandle; MyWindow: WindowPtr; FontList, SizeList: ListHandle; FontRect, SizeRect, TextRect: Rect; CurrFont, CurrSize: INTEGER; procedure Initialize; begin (*------------------------------------------------------------------------------------------*) (* Initialize the toolbox and most of our global variables. *) (*------------------------------------------------------------------------------------------*) {$IFC UNDEFINED MWERKS} InitGraf(@thePort); {$ELSEC} InitGraf(@qd.thePort); {$ENDC} InitFonts; InitWindows; InitMenus; TEInit; InitDialogs(nil); CurrFont := 1; (* Use the default "Application" font *) CurrSize := 12; (* 12 points is a good guess as to the size *) myWindow := nil; quit := FALSE; (*------------------------------------------------------------------------------------------*) (* Add the Apple and File menus *) (*------------------------------------------------------------------------------------------*) AppleMenu := GetMenu(mApple); AppendResMenu(AppleMenu, 'DRVR'); {AddResMenu} InsertMenu(AppleMenu, 0); FileMenu := GetMenu(mFile); InsertMenu(FileMenu, 0); DrawMenuBar; InitCursor; end; (* Initialize *) procedure SelectFont (fontName: Str255); var fontNum: INTEGER; theCell: Cell; found: Boolean; begin (*------------------------------------------------------------------------------------------*) (* Select the named font. *) (* *) (* This procedure sets our current font to the named font, marks the window for *) (* redrawing and hilights the selected font name in the font list. *) (* *) (* We first locate the font name in the list using the LSearch() function. If, for *) (* some strange reason, the name isn't found, then skip the rest of the procedure. Otherwise*) (* we select the cell containing the font name. Also, convert the font name into a font *) (* number and set our current font to that. *) (*------------------------------------------------------------------------------------------*) SetPt(theCell, 0, 0); (* set the starting point for our search *) found := LSearch(POINTER(ORD(@fontname) + 1), length(fontName), nil, theCell, FontList);(* Locate the seletced name in the list *) if found then begin SetPort(MyWindow); (* Mark the text area of the window for redrawing *) InvalRect(TextRect); GetFNum(fontName, fontNum); (* Convert the font name to a number… *) CurrFont := fontNum; (* …and remember the number *) if not (LGetSelect(FALSE, theCell, FontList)) then begin (* If the cell is not presently selected, *) TextFace([]); (* then select it *) TextSize(12); (* NOTE: if we don't set the font/style/size first, *) TextFont(0); (* the list may not be re-drawn properly. *) LSetSelect(TRUE, theCell, FontList); if not (PtInRect(theCell, FontList^^.dataBounds)) then LAutoScroll(FontList); (* If the selected cell isn't on screen, *) (* THEN scroll it to the top of the list *) end; end; end; (* SelectFont *) procedure SelectSize (sizeString: Str255); var sizeVal, count: INTEGER; theCell: Cell; found: Boolean; begin (*------------------------------------------------------------------------------------------*) (* Set the font size. *) (* *) (* This procedure is basically the same as the one above, except that it's working with*) (* the font size information. *) (*------------------------------------------------------------------------------------------*) SetPt(theCell, 0, 0); (* set the starting point for our search *) found := LSearch(POINTER(ORD(@sizeString) + 1), length(sizeString), nil, theCell, SizeList);(* Locate the selected size in the list *) if found then begin SetPort(MyWindow); InvalRect(TextRect); (* Convert the string into an integer *) sizeVal := 0; for count := 1 to LENGTH(sizeString) do if (sizeString[count] >= '0') and (sizeString[count] <= '9') then sizeVal := 10 * sizeVal + (ORD(sizeString[count]) - ORD('0')); CurrSize := sizeVal; if not (LGetSelect(FALSE, theCell, SizeList)) then begin TextFace([]); TextSize(12); TextFont(0); LSetSelect(TRUE, theCell, SizeList); (* so set the selection point *) if not (PtInRect(theCell, FontList^^.dataBounds)) then LAutoScroll(SizeList); (* If the selected cell isn't on screen, *) (* THEN scroll it to the top of the list *) end; end; end; (* SelectSize *) procedure OpenMyWindow; var apFontName: Str255; procedure CreateLists; const notDrawn = FALSE; (* symbolic constants used to make LNew() more readable *) noGrow = FALSE; noHScroll = FALSE; vScroll = TRUE; var dataBounds: Rect; cellSize: Point; numFonts, firstRow, count: INTEGER; fontRsrc: Handle; theID: INTEGER; theType: resType; name: Str255; theCell: Cell; begin SetRect(FontRect, 10, 10, 230, 140); (* This rectangle will hold a list of fonts *) SetRect(SizeRect, 240, 10, 310, 140); (* This rectangle will hold a list of font sizes *) SetRect(dataBounds, 0, 0, 1, 0); (* Specify an initial list that's 1 column wide by 0 rows deep *) SetPt(cellSize, 0, 0); (* Let the list manager calculate the cell size *) (*------------------------------------------------------------------------------------------*) (* Create an empty font list, 0 rows by 1 column *) (*------------------------------------------------------------------------------------------*) FontRect.right := FontRect.right - 16; (* The rectangle passed to LNew determines the size of the body *) (* of the list; scroll bars are placed outside of the rectangle *) (* Therefore, you should set your rectangle for the proper size *) (* including the scroll bars, and adjust it before creating the *) (* list. *) FontList := LNew(FontRect, dataBounds, cellSize, 0, myWindow, notDrawn, noGrow, noHScroll, vScroll); (* Create the list with the given physical boundaries, size, *) (* and options. Note that it has to be attached to a window (a *) (* dialog or alert will also work *) FontList^^.selFlags := lDoHAutoscroll + lOnlyOne; (* Set the options for this list (NOTE: we really don't have to *) (* do this as these are the default settings, namely, allow *) (* automatic scrolling and only select one cell at a time. But,*) (* it never hurts to make certain that your options are set *) (* properly. *) FontRect.right := FontRect.right + 16; (*------------------------------------------------------------------------------------------*) (* Fill in the font list. *) (* *) (* We create the font list by counting the number of fonts in the system and adding that *) (* many rows to our list. Then, we get each font name and append it to the end of the list.*) (* *) (* A note on strings and the List Manager: *) (* All "pascal-format" strings contain a length byte as the first character. The List *) (* Manager only wants the charaters contained in the string, without the length byte. So, *) (* when we pass the information to the List manager, we need to pass a pointer to the second*) (* character of the string. The expression *) (* POINTER(ORD(@string)+1) *) (* gets the address of the second character of the string. *) (*------------------------------------------------------------------------------------------*) numFonts := CountResources('FOND'); (* get the number of fonts *) firstRow := LAddRow(numFonts, 0, FontList); (* Insert the proper number of rows *) for count := 1 to numFonts do begin fontRsrc := GetIndResource('FOND', count); (* get each font *) GetResInfo(fontRsrc, theID, theType, name);(* and gets it's name (among other things) *) SetPt(theCell, 0, count - 1); (* select the proper cell *) LSetCell(POINTER(ORD(@name) + 1), length(name), theCell, FontList); (* and copy the information into it *) end; (*------------------------------------------------------------------------------------------*) (* Create the Size list, o rows deep by 1 column wide *) (*------------------------------------------------------------------------------------------*) SizeRect.right := SizeRect.right - 16; SizeList := LNew(SizeRect, dataBounds, cellSize, 0, myWindow, notDrawn, noGrow, noHScroll, vScroll); SizeRect.right := SizeRect.right + 16; (*------------------------------------------------------------------------------------------*) (* Fill in the size list. *) (* *) (* We fill in the size list from a STR# resource (a list of strings). Since Pascal *) (* makes it hard to get the number of strings in the list, we'll get each string one at a *) (* time and create the new rows as we go. We're using strings instead of integers since *) (* the default list format is "string" and writing a custom list definition is outside the *) (* scope of this example. *) (*------------------------------------------------------------------------------------------*) count := 1; repeat GetIndString(name, sizes, count); (* Get a size value from our list, or '' if we *) if (name <> '') then (* are at the end of the list of strings *) begin firstRow := LAddRow(1, -1, SizeList); (* LAddRow will insert (the first number shown) rows starting *) (* at row (the second number). If the starting point is not *) (* within the list, LAddRow appends the requested number of *) (* rows. Therefore, we are appending 1 row and getting beck *) (* the number of the new row. *) SetPt(theCell, 0, firstRow); (* get the cell we just installed… *) LSetCell(POINTER(ORD(@name) + 1), length(name), theCell, SizeList); (* …and copy the information into it *) count := count + 1; end; until (name = ''); TextFace([]); (* Select the "System Font" (Chicago) before drawing the lists *) TextSize(12); TextFont(0); {LDoDraw remaned to LSetDrawingMode /IR} LSetDrawingMode(TRUE, FontList); (* we turned off drawing while building the lists *) LSetDrawingMode(TRUE, SizeList); (* so we need to turn it on now *) end; (* CreateLists *) begin (*------------------------------------------------------------------------------------------*) (* Create the window, if it doesn't exist already *) (* *) (* After we create the window, we'll attach the lists (yes, you have to create a window *) (* before creating any lists) and slect our initial font and size (which includes setting *) (* the hilights in the 2 lists). *) (*------------------------------------------------------------------------------------------*) if (myWindow = nil) then begin myWindow := GetNewWindow(wList, nil, WindowPtr(-1)); DisableItem(FileMenu, ifNew); (* Set the File menu entries so we can't open another window *) EnableItem(FileMenu, ifClose); CreateLists; GetFontName(1, apFontName); (* get the name of the current application font *) SelectFont(apFontName); (* and use this font initially *) SelectSize('12'); (* Use 12 point characters *) SetRect(TextRect, 10, 150, 310, 190); (* This will hold the actual text display *) end end; (* OpenMyWindow *) procedure CloseMyWindow; begin (*------------------------------------------------------------------------------------------*) (* Remove the window *) (* *) (* Before we get rid of the window, we need to dispose of the lists (or risk a System *) (* Error message). We'll also reset the File menu so we can open the window again. *) (*------------------------------------------------------------------------------------------*) if (myWindow <> nil) then begin LDispose(FontList); (* Get rid of the lists… *) LDispose(SizeList); DisposeWindow(myWindow); (* and the window *) myWindow := nil; (* mark the window as disposed *) EnableItem(FileMenu, ifNew); (* and set the file menu so the user can open *) DisableItem(FileMenu, ifClose); (* a window *) end; end; (* CloseMyWindow *) procedure DoMenus (menuCode: longint); var inMenu, inItem: integer; (* The following variables are used when opening a desk accessory *) DAName: Str255; oldPort: GrafPtr; scratch: integer; (* Variables used with our "About" dialog *) aboutDlg: DialogPtr; itemHit: INTEGER; begin (*------------------------------------------------------------------------------------------*) (* Process a menu request *) (* *) (* We have to separate the menu code into its 2 parts, then take the appropriate *) (* actions. *) (*------------------------------------------------------------------------------------------*) if MenuCode <> 0 then begin inMenu := HiWord(menuCode); inItem := LoWord(menuCode); case inMenu of mApple: if (inItem = iaAbout) then begin aboutDlg := GetNewDialog(dAbout, nil, WindowPtr(-1)); if (aboutDlg <> nil) then ModalDialog(nil, itemHit); DisposeDialog(aboutDlg); end else begin (* We have a desk accessory *) (* Some DAs are ill-behaved and change the current GrafPort, so we'll save *) (*and restore around them *) GetPort(oldPort); GetMenuItemText(AppleMenu, inItem, DAName); (* (GetItem) Get the DA's name *) scratch := OpenDeskAcc(DAName); (* (OpenDeskAcc) Open it *) SetPort(oldPort); (* and get our current window setting back *) end; (* Apple menu selected *) mFile: case inItem of ifNew: OpenMyWindow; ifClose: CloseMyWindow; ifQuit: quit := TRUE; end; (* mFile: CASE inItem *) otherwise SysBeep(5); end; (* CASE inMenu *) HiliteMenu(0); end; end; (* DoMenus *) procedure DoUpdate (whichWindow: WindowPtr); var message: Str255; scratch: Rect; begin (*------------------------------------------------------------------------------------------*) (* Update the window. *) (* *) (* The window contains three parts that we have to update -- the text area and the 2 *) (* lists. *) (* *) (* Notice the adjustments we make to the list rectangles before framing them. If you *) (* don't do this, the framing rectangles might come out looking a little strange! *) (*------------------------------------------------------------------------------------------*) BeginUpdate(whichWindow); SetPort(whichWindow); EraseRgn(whichWindow^.visRgn); (* Erase the area to be updated *) TextFace([]); (* Just plain text *) TextSize(CurrSize); (* Our selected size *) TextFont(CurrFont); (* our selected font *) message := 'The quick brown fox jumped over the lazy dog.'; TETextBox(POINTER(ORD(@message) + 1), length(message), TextRect, teJustLeft); {TextBox} InsetRect(TextRect, -2, -2); (* set up a 2-pixel margin around the text *) FrameRect(TextRect); InsetRect(TextRect, 2, 2); TextFont(0); (* Reset to the current System font *) TextSize(12); LUpdate(whichWindow^.visRgn, FontList); (* Draw the font list *) LUpdate(whichWindow^.visRgn, SizeList); (* Draw the size list *) scratch := FontRect; (* Frame the font list *) InsetRect(scratch, -1, -1); scratch.right := scratch.right - 15; FrameRect(scratch); scratch := SizeRect; (* Frame the size list *) InsetRect(scratch, -1, -1); scratch.right := scratch.right - 15; FrameRect(scratch); EndUpdate(whichWindow); end; (* DoUpdate *) procedure DoMouseClick (theEvent: EventRecord; theWindow: WindowPtr); var localClick: Point; isDoubleClick, isSelected: Boolean; theCell: Cell; nameLen, sizeLen: INTEGER; fontName, sizeString: Str255; begin (*------------------------------------------------------------------------------------------*) (* Handle a MouseDown event in our window *) (* *) (* We need to check if the click was in one of the lists and, if so, call LClick() for *) (* the appropriate list. *) (* *) (* NOTE: LClick() expects the location to be in local coordinates. If you forget to *) (* convert the mouse location to local coordinates, your lists won't select properly and *) (* you'll get all sorts of strange behaviors! *) (*------------------------------------------------------------------------------------------*) localClick := theEvent.where; SetPort(theWindow); GlobalToLocal(localClick); if PtInRect(localClick, FontRect) then begin isDoubleClick := LClick(localClick, theEvent.modifiers, FontList); (* process the mouse click *) SetPt(theCell, 0, 0); isSelected := LGetSelect(TRUE, theCell, FontList); (* Find the first (and only) selected *) (* cell at a location greater than or *) (* equal to (0,0) *) nameLen := 255; (* The maximum number of chars allowed in the string *) LGetCell(POINTER(ORD(@fontName) + 1), nameLen, theCell, FontList); (* Get the text of the selected cell *) {$R- Turn off range checking for the next operation, since Pascal doesn't like you to change the string length byte } fontName[0] := CHR(nameLen); (* Set the length byte of the string *) {$R+ Range checking is back on} SelectFont(fontName); (* Use the selected font *) end; if PtInRect(localClick, SizeRect) then begin isDoubleClick := LClick(localClick, theEvent.modifiers, SizeList); (* process the mouse click *) SetPt(theCell, 0, 0); isSelected := LGetSelect(TRUE, theCell, SizeList); (* Find the first (and only) selected *) (* cell at a location greater than or *) (* equal to (0,0) *) sizeLen := 255; (* The maximum number of chars allowed in the string *) LGetCell(POINTER(ORD(@sizeString) + 1), sizeLen, theCell, SizeList); (* Get the text of the selected cell *) {$R- Turn off range checking} sizeString[0] := CHR(sizeLen); (* Set the length byte of the string *) {$R+ Range checking is back on} SelectSize(sizeString); (* Use the selected size *) end; end; (* DoMouseClick *) procedure MainLoop; var theEvent: EventRecord; location: integer; whichWindow: WindowPtr; menuCode: longint; ch: char; r: Rect; begin (*------------------------------------------------------------------------------------------*) (* Our main event loop. *) (* *) (* This is a pretty standard main event loop, except that I don't let you drag or *) (* resize the window. Notice the special handling required for Activate events when you *) (* are working with lists. *) (*------------------------------------------------------------------------------------------*) repeat SystemTask; if GetNextEvent(everyEvent, theEvent) then case (theEvent.what) of mouseDown: begin location := FindWindow(theEvent.where, whichWindow); case location of inMenuBar: begin menuCode := MenuSelect(theEvent.where); DoMenus(menuCode); end; (* mouse in menu bar *) inContent: if FrontWindow <> whichWindow then SelectWindow(whichWindow) (* Bring this window to the front *) else DoMouseClick(theEvent, whichWindow); (* The user clicked in our window *) inGoAway: if TrackGoAway(whichWindow, theEvent.where) then CloseMyWindow; inSysWindow: SystemClick(theEvent, whichWindow); inDrag: {Added by Ingemar R} begin if (whichWindow <> FrontWindow) and (BitAnd(theEvent.modifiers, cmdKey) = 0) then SelectWindow(whichWindow); {Limit the dragging so that the window can't be dragged too far.} {$IFC UNDEFINED MWERKS} r := screenBits.bounds; {$ELSEC} r := qd.screenBits.bounds; {$ENDC} InsetRect(r, 4, 4); DragWindow(whichWindow, theEvent.where, r); end; otherwise ; end; (* CASE location *) end; (* mouseDown *) keyDown: (* If it's a menu selection, then handle it *) if (BitAnd(theEvent.modifiers, CmdKey) <> 0) then begin ch := chr(BitAnd(theEvent.message, CharCodeMask)); menuCode := MenuKey(ch); DoMenus(menuCode); end; (* IF we have a command key *) updateEvt: DoUpdate(WindowPtr(theEvent.message)); activateEvt: if (WindowPtr(theEvent.message) = MyWindow) then if ODD(theEvent.modifiers) then begin (* Our window is coming to the front *) LActivate(TRUE, FontList); (* Enable the scroll bar, turn on the hilight, etc. *) LActivate(TRUE, SizeList); end else begin (* Our window is going behind another one *) LActivate(FALSE, FontList); (* Deactivate the scroll bar, hide the hilight *) LActivate(FALSE, SizeList); end; otherwise ; end; (* CASE theEvent.what *) until quit; end; (* MainLoop *) procedure Cleanup; begin CloseMyWindow; end; (* Cleanup *) begin Initialize; OpenMyWindow; MainLoop; Cleanup; end. 
